home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Visual Database / Visual Foxpro 6.0 (Ent. Edition) / Vf6ent Extractor.EXE / VFPXTAB.PRG < prev    next >
Encoding:
Text File  |  1998-05-26  |  41.7 KB  |  1,527 lines
  1. *:*********************************************************************
  2. *:
  3. *: Procedure file: VFPXTAB.PRG
  4. *:
  5. *:        System: GENXTAB
  6. *:        Author: Microsoft Corp.
  7. *:        Copyright (c) 1993,1994,1995 Microsoft Corp.
  8. *:        Version: 4.0
  9. *:
  10. *:*********************************************************************
  11. ***********************************************************************
  12. *
  13. * Notes: This program is intended to be called by RQBE or a program
  14. *        generated by RQBE.  On entry, a table should be open in the
  15. *        current work area, and it should contain at most one record
  16. *        for each cell in a cross-tabulation.  This table *must* be in
  17. *        row order, or you will receive an "unexpected end of file"
  18. *        error when you run _GENXTAB.
  19. *
  20. *        The rowfld field in each record becomes the y-axis (rows) for
  21. *        a cross-tab and the colfld field becomes the x-axis (columns)
  22. *        The actual cross-tab results are saved to the database name
  23. *        specified by "outfname."
  24. *
  25. *        The basic strategy goes like this.  Produce an empty database
  26. *        with one field/column for each unique value of input field
  27. *        colfld, plus one additional field for input field rowfld values.
  28. *        This process determines the column headings in the database.
  29. *        Next fill in the rows, but only for the first field in the output
  30. *        database--the one that contains values for input field rowfld.
  31. *        At this point, we have column headings "across the top"
  32. *        and row identifiers "down the side."  Finally, look up
  33. *        the cell values for the row/column intersections and put
  34. *        them into the output database.
  35. *        
  36. * Parameters:
  37. *
  38. *          Parm1 - output file/cursor name (default "xtab.dbf")
  39. *          Parm2 - cursor only (default .F.)
  40. *          Parm3 - close input table after (default .T.)
  41. *          Parm4 - show thermometer (default .T.)
  42. *          Parm5 - row field     (default 1)
  43. *          Parm6 - column field     (default 2)
  44. *          Parm7 - data field     (default 3)
  45. *          Parm8 - total rows    (default .F.)
  46. *          Parm9 - totaling options (0-sum, 1-count, 2-% of total)
  47. *          Parm10 - display Null values
  48. *
  49. * Calling example:
  50. *
  51. *         oNewXtab=CREATE('genxtab','query',.T.,.T.,.T.,1,6,10,.T.,0)
  52. *         oNewXtab.MakeXtab()
  53. *
  54. ***********************************************************************
  55. #DEFINE    C_LOCATEDBF_LOC        "Please locate the input database:"
  56. #DEFINE    C_OUTPUT_LOC        "The input and output databases must be different."
  57. #DEFINE    C_NEED3FLDS_LOC        "Crosstab input databases require at least three fields"
  58. #DEFINE    C_EMPTYDBF_LOC        "Cannot prepare crosstab on empty database"
  59. #DEFINE    C_BADROWFLD_LOC        "The crosstab row field in the input; database cannot be a memo, general or picture  field."
  60. #DEFINE    C_BADCOLFLD_LOC        "The crosstab column field in the input; database cannot be a memo, general or picture field."
  61. #DEFINE    C_BADCELLFLD_LOC    "The crosstab cell field in the input; database cannot be a memo, general or picture field."
  62. #DEFINE    C_NOCOLS_LOC        "No columns found."
  63. #DEFINE    C_XSVALUES_LOC        "There are too many unique values for column field. The maximum is 254."
  64. #DEFINE    C_ENDOUTFILE_LOC    "Unexpected end of output file. The input file may be out of sequence. Check to see that Row field is ordered."
  65. #DEFINE    C_UNKNOWNFLD_LOC    "Unknown field type."
  66. #DEFINE    C_XTABTERM_LOC        "Cross tabulation process halted prematurely. Do you want to continue?"
  67. #DEFINE C_BADALIAS_LOC        "Please use a different alias from one of these reserved words -- THIS, THISFORM, THISFORMSET."
  68.  
  69. #DEFINE ERR_LINE_LOC        "Line: "
  70. #DEFINE ERR_PROGRAM_LOC        "Program: "
  71. #DEFINE ERR_ERROR_LOC        "Error: "
  72. #DEFINE ERR_MESSAGE_LOC        "Message: "
  73. #DEFINE ERR_CODE_LOC        "Code: "
  74.  
  75. #DEFINE    THERMCOMPLETE_LOC    "Complete."
  76. #DEFINE    C_THERM1_LOC        "Generating cross-tab output:"
  77. #DEFINE    C_THERM2_LOC        "Initializing cross-tab engine"
  78. #DEFINE    C_THERM3_LOC        "Reading input field information"
  79. #DEFINE    C_THERM4_LOC        "Creating output datasource"
  80. #DEFINE    C_THERM5_LOC        "Calculating cross-tab values"
  81. #DEFINE    C_THERM6_LOC        "Totaling output columns"
  82.  
  83. #DEFINE    SUM_FIELDS            0
  84. #DEFINE    COUNT_FIELDS        1
  85. #DEFINE    PERCENT_FIELDS        2
  86. #DEFINE AVERAGE_FIELDS        3
  87. #DEFINE MAX_FIELDS            4
  88. #DEFINE MIN_FIELDS            5
  89.  
  90. #DEFINE WIN32FONT            'MS Sans Serif'
  91. #DEFINE WIN95FONT            'Arial'
  92. #DEFINE DBCS_LOC             "81 82 86 88"
  93.  
  94. #DEFINE    C_SUMFIELD_LOC            "Total"
  95. #DEFINE    C_COUNTFIELD_LOC        "Count"
  96. #DEFINE    C_PERCENTFIELD_LOC        "Percent"
  97.  
  98.  
  99. LPARAMETER p1,p2,p3,p4,p5,p6,p7,p8,p9,p10
  100. * For background compatibility with FP2.x
  101. IF PARAMETERS() < 3
  102.     p3 = .T.
  103. ENDIF
  104. IF PARAMETERS() < 4
  105.     p4 = .T.
  106. ENDIF
  107.  
  108. oNewXtab=CREATE("genxtab",m.p1,m.p2,m.p3,m.p4,m.p5,m.p6,m.p7,m.p8,m.p9,m.p10)
  109. IF TYPE("oNewXtab")="O"
  110.     oNewXtab.MakeXtab()
  111. ENDIF
  112.  
  113. ***********************************************************************
  114. ***********************************************************************
  115. DEFINE CLASS genxtab AS custom
  116.  
  117.     shownulls = .F.            &&controls display of NULLs
  118.  
  119.     * Environment settings
  120.     xtalk_stat = ""
  121.     xsafe_stat = ""
  122.     xesc_stat = ""
  123.     mfieldsto = ""
  124.     fields = ""
  125.     udfparms = ""
  126.     mmacdesk = ""
  127.     in_esc = ""
  128.     outstem  = ""
  129.     setnull = ""
  130.     failxtab = .F.
  131.     setcompat = ""
  132.     
  133.     * Parameter defaults
  134.     outfname = "xtab.dbf"
  135.     cursonly = .F.
  136.     closeinput = .T.
  137.     therm_on = .T.
  138.     rowfld = 1
  139.     colfld = 2
  140.     cellfld = 3
  141.     xfoot = .F.
  142.     totaltype = 0
  143.     sumtype = 0
  144.     
  145.     * Default field names, captions and settings
  146.     char_blank =     "C_BLANK"
  147.     date_blank =     "D_BLANK"
  148.     null_field =     "NULL"
  149.     sumtotalfld =    C_SUMFIELD_LOC
  150.     counttotalfld =    C_COUNTFIELD_LOC
  151.     perctotalfld =    C_PERCENTFIELD_LOC
  152.     cCountFldType   = "N"
  153.     nCountFldLen    = 4
  154.     nCountFldDec    = 0
  155.     cPercentFldType = "N"
  156.     nPercentFldLen    = 7
  157.     nPercentFldDec    = 3
  158.  
  159.     * Misc thermometer stuff
  160.       lHasModalFormOnTop = .F.
  161.       cOldMessage = ""
  162.       oThermRef = ""
  163.  
  164.     * Map European characters to these
  165.     stdascii  = 'ueaaaaceeeiiAaEaAooouuyouaiounN'
  166.     badchars  = ""
  167.  
  168.  
  169. *!*********************************************************************
  170. *!
  171. *!       PROCEDURE INIT
  172. *!
  173. *!*********************************************************************
  174. PROCEDURE INIT
  175.  
  176.     PARAMETERS outfname, cursonly, closeinput, showtherm, rowfld, colfld, cellfld, xfoot, totaltype, shownulls
  177.  
  178.     LOCAL cname,nParms,goodchars,i
  179.     m.nParms = PARAMETERS()
  180.     IF USED('THIS') .or. USED('THISFORM') .or. USED('THISFORMSET')
  181.         =MESSAGEBOX(C_BADALIAS_LOC)
  182.         RETURN .F.
  183.     ENDIF
  184.     THIS.save_env()
  185.     IF VERSION(3) $ DBCS_LOC
  186.         this.badchars = '/,-=:;!@#$%&*.<>()?[]\'+;
  187.            '+'+CHR(34)+CHR(39)+" "
  188.     ELSE
  189.         this.badchars = 'üéâäàåçêëèïîÄÅÉæÆôöòûùÿÖÜáíóúñÑ/\,-=:;{}[]!@#$%^&*.<>()?'+;
  190.            '+|Ç¢£¥₧ƒªº¿⌐¬½¼¡«»░▒▓│┤╡╢╖╕╣║╗╝╜╛┐└┴┬├─┼╞╟╚╔╩╦╠═╬╧'+;
  191.            '╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■'+CHR(34)+CHR(39)+" "
  192.     ENDIF
  193.  
  194.     * Set parameters or use default values
  195.     
  196.     IF m.nParms > 0 AND TYPE("m.outfname") = "C"
  197.        THIS.outfname = m.outfname
  198.     ENDIF
  199.     
  200.     * Default to creating the same kind of output as we got as input.
  201.     * If the input "database" is a cursor, make the output a cursor.
  202.     * If the input "database" is an actual database, make the output a table.
  203.     m.cname = THIS.justfname(DBF())
  204.     DO CASE
  205.     CASE EMPTY(m.cname)   && create a table if nothing is currently selected
  206.           THIS.cursonly = .F.
  207.     CASE ATC(".DBF",THIS.outfname)#0
  208.           THIS.cursonly = .F.
  209.     CASE ISDIGIT(LEFT(m.cname,1)) OR ATC(".TMP",m.cname)#0
  210.           THIS.cursonly = .T.
  211.     CASE TYPE("m.cursonly") = "L"
  212.           THIS.cursonly = m.cursonly
  213.     OTHERWISE
  214.         THIS.cursonly = .F.
  215.     ENDCASE
  216.         
  217.     IF m.nParms > 2 AND TYPE("m.closeinput") = "L"
  218.        * Close the input database
  219.        THIS.closeinput = m.closeinput
  220.     ENDIF
  221.  
  222.     IF m.nParms > 3 AND TYPE("m.showtherm ") = "L"
  223.        * show the thermometer
  224.        THIS.Therm_On = m.showtherm
  225.     ENDIF
  226.     
  227.     IF m.nParms > 4 AND TYPE("m.rowfld ") = "N"
  228.        * the field position in the input database for the crosstab rows
  229.        THIS.rowfld = m.rowfld
  230.     ENDIF
  231.     
  232.     IF m.nParms > 5  AND TYPE("m.colfld") = "N"
  233.        * the field position in the input database for the crosstab columns
  234.        THIS.colfld = m.colfld
  235.     ENDIF
  236.     
  237.     IF m.nParms > 6  AND TYPE("m.cellfld") = "N"
  238.        * the field position in the input database for the crosstab cells
  239.        THIS.cellfld = m.cellfld 
  240.     ENDIF
  241.     
  242.     IF m.nParms  > 7 AND TYPE("m.xfoot") = "L"
  243.        * Create a total field
  244.        THIS.xfoot = m.xfoot
  245.     ENDIF
  246.  
  247.     IF m.nParms  > 8 AND TYPE("m.totaltype") = "N"
  248.        * Create a total field
  249.        THIS.totaltype = m.totaltype
  250.     ENDIF
  251.  
  252.     IF m.nParms  > 9 AND TYPE("m.shownulls") = "L"
  253.        * Display nulls
  254.        THIS.shownulls = m.shownulls
  255.     ENDIF
  256.     
  257.     IF THIS.shownulls
  258.         SET NULL ON
  259.     ELSE
  260.         SET NULL OFF
  261.     ENDIF
  262.  
  263.     THIS.outfname = THIS.removequotes(THIS.outfname)
  264.     THIS.outstem = THIS.juststem(THIS.outfname)
  265.     
  266.     * Let's set the true bad characters which aren't allowed in fields
  267.     * Note: this will differ based on code page
  268.     m.goodchars=""
  269.     FOR i = 1 TO LEN(THIS.badchars)
  270.         IF ISALPHA(SUBSTR(THIS.badchars,m.i,1))
  271.             m.goodchars = m.goodchars + SUBSTR(THIS.badchars,m.i,1)
  272.         ENDIF
  273.     ENDFOR
  274.     THIS.badchars = CHRTRAN(m.THIS.badchars,m.goodchars,'')
  275. ENDPROC
  276.  
  277. *!*********************************************************************
  278. *!
  279. *!       PROCEDURE save_env
  280. *!
  281. *!*********************************************************************
  282. PROCEDURE save_env
  283.     IF SET("TALK") = "ON"
  284.        SET TALK OFF
  285.        THIS.xtalk_stat = "ON"
  286.     ELSE
  287.        THIS.xtalk_stat = "OFF"
  288.     ENDIF
  289.  
  290.     THIS.setcompat = SET("COMP")
  291.     SET COMP OFF
  292.     THIS.cOldMessage = SET("MESSAGE",1)
  293.     THIS.xsafe_stat = SET("SAFETY")
  294.     SET SAFETY OFF
  295.     THIS.xesc_stat = SET("ESCAPE")
  296.     SET ESCAPE ON
  297.     THIS.mfieldsto = SET("FIELDS",1)
  298.     THIS.fields = SET("FIELDS")
  299.     SET FIELDS TO
  300.     SET FIELDS OFF
  301.     THIS.udfparms = SET("UDFPARMS")
  302.     SET UDFPARMS TO VALUE
  303.     THIS.setnull = SET("NULL")
  304.  
  305.     #IF "MAC" $ UPPER(VERSION(1))
  306.        IF _MAC
  307.           THIS.mmacdesk = SET("MACDESKTOP")
  308.            SET MACDESKTOP ON
  309.        ENDIF
  310.     #ENDIF
  311.  
  312.     THIS.in_esc = ON('ESCAPE')
  313. ENDPROC
  314.  
  315. *!*********************************************************************
  316. *!
  317. *!       PROCEDURE Destroy
  318. *!
  319. *!*********************************************************************
  320. PROCEDURE Destroy
  321.  
  322. PRIVATE docancl,cTmpStr
  323.  
  324. IF USED("XTABTEMP")
  325.    USE IN xtabtemp
  326. ENDIF
  327.  
  328. IF FILE("xtabtemp.dbf")
  329.    DELETE FILE xtabtemp.dbf
  330. ENDIF
  331. IF EMPTY(THIS.cOldMessage)
  332.     SET MESSAGE TO
  333. ELSE
  334.     SET MESSAGE TO THIS.cOldMessage
  335. ENDIF
  336. m.cTmpStr = THIS.mfieldsto
  337. SET FIELDS TO &cTmpStr
  338. IF THIS.fields = "ON"
  339.        SET FIELDS ON
  340. ELSE
  341.        SET FIELDS OFF
  342. ENDIF
  343.  
  344. cTmpStr=THIS.udfparms
  345. SET UDFPARMS TO &cTmpStr
  346.  
  347. IF THIS.xsafe_stat = "ON"
  348.    SET SAFETY ON
  349. ENDIF
  350. IF THIS.xesc_stat = "ON"
  351.    SET ESCAPE ON
  352. ELSE
  353.    SET ESCAPE OFF
  354. ENDIF
  355. IF THIS.setnull = "OFF"
  356.     SET NULL OFF
  357. ELSE
  358.     SET NULL ON
  359. ENDIF
  360. IF THIS.xtalk_stat = "ON"
  361.    SET TALK ON
  362. ENDIF
  363. IF THIS.setcompat = "ON"
  364.     SET COMP ON
  365. ENDIF
  366. #IF "MAC" $ UPPER(VERSION(1))
  367.    IF _MAC
  368.        m.cTmpStr = THIS.mmacdesk
  369.        SET MACDESKTOP &cTmpStr 
  370.    ENDIF
  371. #ENDIF
  372.  
  373. cTmpStr = THIS.in_esc
  374. ON ESCAPE &cTmpStr
  375.  
  376. IF THIS.failxtab    
  377.     THIS.outfname = ''
  378.     THIS.deactthermo()
  379. ENDIF
  380.  
  381. ENDPROC
  382.  
  383. *!*********************************************************************
  384. *!
  385. *!       Function: MakeXTab()
  386. *!
  387. *!*********************************************************************
  388. PROCEDURE MakeXTab
  389.     * Set ON ESCAPE here
  390.     LOCAL oThisXtab
  391.     oThisXtab = THIS.Name+".esc_proc()"
  392.     ON ESCAPE &oThisXtab
  393.     
  394.     * Call main program
  395.     THIS.RunXTab()
  396. ENDPROC
  397.  
  398. *!*********************************************************************
  399. *!
  400. *!       Function: RunXTab()
  401. *!
  402. *!*********************************************************************
  403. PROCEDURE RunXTab
  404.  
  405. LOCAL dbfname,dbfstem,ok,cdec,i,tempdbf
  406. LOCAL numflds,rowfldname,colfldname,cellfldname
  407. LOCAL totfldname,gtotal,outf1name,f1,f2,f3
  408. LOCAL colcnt,coluniq,outarray,nTotFields,cSaveFld 
  409. LOCAL sumallflds,RowFldType,cTmpField
  410. LOCAL nFldLen,cFldType,nFldDec,nAccumTot,nTmpTot 
  411. DIMENSION colcnt[1],coluniq[1],outarray[1]
  412.  
  413. m.dbfname = ALIAS()
  414. m.dbfstem = THIS.Juststem(m.dbfname)
  415.  
  416. THIS.acttherm(C_THERM1_LOC)
  417. THIS.updtherm(5,C_THERM2_LOC)
  418.  
  419. * Select one, if no database is open in the current workarea
  420. m.ok = .F.
  421. DO WHILE NOT m.ok
  422.    DO CASE
  423.    CASE EMPTY(m.dbfname)
  424.       m.dbfname = GETFILE('DBF',C_LOCATEDBF_LOC)
  425.       m.dbfstem = THIS.juststem(m.dbfname)
  426.       IF EMPTY(m.dbfname)
  427.          * User canceled out of dialog, so quit the program
  428.          THIS.failxtab = .T.
  429.          RETURN
  430.       ENDIF
  431.    CASE FULLPATH(THIS.defaultext(m.dbfname,'DBF')) == ;
  432.          FULLPATH(THIS.defaultext(THIS.outfname,'DBF'))
  433.       THIS.ALERT(C_OUTPUT_LOC)
  434.       m.dbfname = ''
  435.    OTHERWISE
  436.       IF USED(m.dbfstem)
  437.          SELECT (m.dbfstem)
  438.       ELSE
  439.          SELECT 0
  440.          USE (m.dbfname) ALIAS (m.dbfstem)
  441.       ENDIF
  442.       IF FCOUNT() < 3
  443.          THIS.ALERT(C_NEED3FLDS_LOC)
  444.          m.dbfname = ''
  445.       ELSE
  446.          ok = .T.
  447.       ENDIF
  448.    ENDCASE
  449. ENDDO
  450.  
  451. IF RECCOUNT() = 0
  452.     THIS.ALERT(C_EMPTYDBF_LOC)
  453.     THIS.failxtab = .T.
  454.     RETURN
  455. ENDIF
  456.    
  457. * Gather information on the currently selected database fields
  458.  
  459. DIMENSION inpfields[FCOUNT(),4]
  460. m.numflds = AFIELDS(inpfields)
  461.  
  462. * Map the physical input database field to logical field positions
  463.  
  464. m.rowfldname    = inpfields[THIS.rowfld,1]
  465. m.colfldname    = inpfields[THIS.colfld,1]
  466. m.cellfldname   = inpfields[THIS.cellfld,1]
  467.  
  468. * None of these fields are allowed to be memo fields
  469. IF inpfields[THIS.rowfld,2] $ 'MGP'
  470.    THIS.ALERT(C_BADROWFLD_LOC)
  471.    THIS.failxtab = .T.
  472.    RETURN
  473. ENDIF
  474. IF inpfields[THIS.colfld,2] $ 'MGP'
  475.    THIS.ALERT(C_BADCOLFLD_LOC)
  476.    THIS.failxtab = .T.
  477.    RETURN
  478. ENDIF
  479. IF inpfields[THIS.cellfld,2] $ 'MGP'
  480.    THIS.ALERT(C_BADCELLFLD_LOC)
  481.    THIS.failxtab = .T.
  482.    RETURN
  483. ENDIF
  484.  
  485. * Count the number of columns we need to create the cross tab.
  486. * This step could be combined with the following one so that there
  487. * would only be one SELECT operation performed.  It is coded in this
  488. * way to avoid running out of memory if there are an unexpectedly
  489. * large number of unique values of field 2 in the input database.
  490.  
  491. THIS.updtherm(10,C_THERM3_LOC)
  492. tempdbf = IIF(UPPER(JUSTEXT(DBF()))#"TMP",DBF(),m.dbfname)
  493. SELECT COUNT(DISTINCT &colfldname) FROM (m.tempdbf) INTO ARRAY colcnt
  494.  
  495. DO CASE
  496. CASE colcnt[1] > 254
  497.    THIS.ALERT(C_XSVALUES_LOC)
  498.    THIS.failxtab = .T.
  499.    RETURN
  500. CASE colcnt[1] = 0
  501.    THIS.ALERT(C_NOCOLS_LOC)
  502.    THIS.failxtab = .T.
  503.    RETURN
  504. ENDCASE
  505.  
  506. * Get the number of decimal places in numeric fields
  507. * and extract all the unique values of colfldname  
  508. IF inpfields[THIS.colfld,2] $ 'NFB'   && numeric or floating field
  509.    m.cdec = inpfields[THIS.colfld,4]
  510.    * Handle numbers separately to preserve correct sort order
  511.    SELECT DISTINCT &colfldname ;
  512.       FROM (m.tempdbf) INTO ARRAY coluniq
  513.    FOR i = 1 TO ALEN(coluniq)
  514.       coluniq[m.i] = THIS.mapname(coluniq[m.i],m.cdec)
  515.    ENDFOR
  516. ELSE        && non-numeric field
  517.    m.cdec = 0
  518.    * Create an array to hold the output database fields.
  519.    SELECT DISTINCT EVAL("THIS.mapname(&colfldname,m.cdec)") FROM (m.tempdbf) INTO ARRAY coluniq
  520. ENDIF
  521.  
  522. THIS.updtherm(15,C_THERM3_LOC)
  523.  
  524. * The field type, length and decimals in the output array control the
  525. * cross-tab cells
  526. IF !THIS.xfoot
  527.    DIMENSION outarray[ALEN(coluniq)+1,5]
  528. ELSE
  529.    DIMENSION outarray[ALEN(coluniq)+2,5]
  530. ENDIF
  531.  
  532. * Field 1 in the output DBF holds the unique values of the row input field.
  533. * It is handled separately from the other fields, which take their names
  534. * from input database colfld and their parameters (e.g., length) from
  535. * input database cellfld.
  536.  
  537. outarray[1,1] = THIS.mapname(inpfields[THIS.rowfld,1])
  538. outarray[1,2] = inpfields[THIS.rowfld,2]                        && field type
  539. outarray[1,3] = inpfields[THIS.rowfld,3]                         && field length
  540. outarray[1,4] = inpfields[THIS.rowfld,4]                        && decimals
  541. outarray[1,5] = .T.                                                && allow NULLs
  542.  
  543. m.RowFldType = outarray[1,2]
  544.  
  545. * Get field data type, width, and deci
  546. cFldType = inpfields[THIS.cellfld,2]                  
  547. nFldLen  = inpfields[THIS.cellfld,3]                  
  548. nFldDec  = inpfields[THIS.cellfld,4]                  
  549.  
  550. * Set data types for data cells
  551. FOR i = 2 TO ALEN(coluniq) + 1
  552.    outarray[m.i,1] = THIS.mapname(coluniq[m.i-1],m.cdec)        && field name
  553.    outarray[m.i,2] = m.cFldType                                 && field type
  554.    outarray[m.i,3] = m.nFldLen                                     && field length
  555.    outarray[m.i,4] = m.nFldDec                                     && decimals
  556.    outarray[m.i,5] = .T.                                        && allow NULLs
  557. ENDFOR
  558.  
  559. outarray[1,1] = THIS.CheckField(@coluniq,outarray[1,1])
  560. cSaveFld = outarray[1,1]
  561.  
  562. * Create a field for the cross-footing, if that option was selected
  563. * By default, make sure we have a numeric field here
  564.  
  565. * Check type of data field, and use count if not numeric.
  566. IF ATC(inpfields[THIS.cellfld,2],"NFYBI") = 0 
  567.     THIS.totaltype = COUNT_FIELDS
  568. ENDIF
  569.  
  570. IF THIS.xfoot
  571.    nTotFields = ALEN(coluniq)+2
  572.    DO CASE
  573.    CASE THIS.totaltype = COUNT_FIELDS
  574.            * Since Max columns is 256, assume N (4)
  575.        outarray[m.nTotFields,1] = THIS.CountTotalFld
  576.        outarray[m.nTotFields,2] = THIS.cCountFldType        && field type
  577.        outarray[m.nTotFields,3] = THIS.nCountFldLen        && field length
  578.        outarray[m.nTotFields,4] = THIS.nCountFldDec        && field length
  579.    CASE THIS.totaltype = PERCENT_FIELDS
  580.            * Percent of total, use three decimals
  581.           outarray[m.nTotFields,1] = THIS.perctotalfld
  582.        outarray[m.nTotFields,2] = THIS.cPercentFldType    && field type
  583.        outarray[m.nTotFields,3] = THIS.nPercentFldLen    && field length
  584.          outarray[m.nTotFields,4] = THIS.nPercentFldDec    && decimals
  585.    OTHERWISE
  586.        outarray[m.nTotFields,1] = THIS.sumtotalfld
  587.        outarray[m.nTotFields,2] = inpfields[THIS.cellfld,2]           && field type
  588.        outarray[m.nTotFields,4] = inpfields[THIS.cellfld,4]           && decimals
  589.        IF ATC(inpfields[THIS.cellfld,2],"YB")#0
  590.            outarray[m.nTotFields,3] = inpfields[THIS.cellfld,3]        && field length    
  591.        ELSE
  592.              * Add a little extra space for calculations
  593.            outarray[m.nTotFields,3] = MIN(inpfields[THIS.cellfld,3]+2,20)    && field length
  594.        ENDIF
  595.    ENDCASE
  596.    outarray[m.nTotFields,5] = .T.    &&allow nulls    
  597.  
  598.    * Check for unique name
  599.    IF ALLTRIM(UPPER(outarray[m.nTotFields,1]))==ALLTRIM(UPPER(outarray[1,1]))
  600.            DO CASE
  601.            CASE LEN(ALLTRIM(outarray[1,1]))<9
  602.                outarray[m.nTotFields,1] = ALLTRIM(outarray[1,1])+"_1"
  603.         CASE RIGHT(outarray[1,1],2) = "_1"
  604.                outarray[m.nTotFields,1] = LEFT(outarray[1,1],8)+"_2"
  605.         OTHERWISE
  606.                outarray[m.nTotFields,1] = LEFT(outarray[1,1],8)+"_1"
  607.            ENDCASE
  608.    ENDIF
  609.    outarray[m.nTotFields,1] = THIS.CheckField(@coluniq,outarray[m.nTotFields,1])
  610. ENDIF    
  611.  
  612. * Make sure that the output file is not already in use somewhere
  613. IF USED(THIS.outstem)
  614.    SELECT (THIS.outstem)
  615.    USE
  616. ENDIF
  617.  
  618. IF !THIS.cursonly
  619.    CREATE TABLE (THIS.outfname) FROM ARRAY outarray
  620.    THIS.outstem = ALIAS()  &&ensure we have correct long name
  621. ELSE
  622.    CREATE CURSOR (THIS.outstem) FROM ARRAY outarray
  623. ENDIF
  624.  
  625. THIS.updtherm(25,C_THERM3_LOC)
  626.  
  627. * Get rid of the temporary arrays
  628. RELEASE outarray, coluniq, inpfields
  629.  
  630. * -------------------------------------------------------------------------
  631. * Add output database rows and replace the first field
  632. * -------------------------------------------------------------------------
  633.  
  634. * Select distinct rows into a table (instead of an array) so that 
  635. * there can be lots of rows.  If we select into an array, we may 
  636. * run out of RAM if there are many rows.
  637.  
  638. SELECT DISTINCT &rowfldname. AS &cSaveFld. FROM (m.tempdbf) INTO TABLE xtabtemp
  639. THIS.updtherm(30,C_THERM4_LOC)
  640.  
  641. SELECT (THIS.outstem)
  642. GO TOP
  643. APPEND FROM xtabtemp FIELD (FIELD(1))
  644.  
  645.  
  646. THIS.updtherm(35,C_THERM5_LOC)
  647.  
  648. * -------------------------------------------------------------------------
  649. * Look up and replace the cell values
  650. * -------------------------------------------------------------------------
  651. *
  652. * This algorithm makes one pass through the input file, dropping its
  653. * values into the output file.  It exploits the fact that the output
  654. * file is known to be in row order.
  655. *
  656.  
  657. * Start at the top of the output file
  658. SELECT (THIS.outstem)
  659. GOTO TOP
  660. outf1name = FIELD(1)
  661.  
  662. * Start at the top of the input file
  663. SELECT (m.dbfstem)
  664. GOTO TOP
  665.  
  666. SCAN
  667.  
  668.    m.f1 = EVAL(m.rowfldname)                          && get next row value from input
  669.    m.f2 = THIS.mapname(EVAL(m.colfldname),m.cdec)   && get corresponding column value
  670.    m.f3 = EVAL(m.cellfldname)                         && get cell value
  671.    
  672.    * Find the right row in the output file
  673.    SELECT (THIS.outstem)
  674.    
  675.    GO TOP
  676.    
  677.    DO WHILE !EOF()
  678.        DO CASE
  679.        CASE ISNULL(EVAL(outf1name)) AND ISNULL(m.f1)
  680.         EXIT
  681.        CASE EVAL(outf1name) == m.f1
  682.            EXIT
  683.        ENDCASE
  684.       SKIP
  685.    ENDDO
  686.    
  687.    IF EOF()
  688.       THIS.ALERT(C_ENDOUTFILE_LOC)
  689.       THIS.failxtab = .T.
  690.       RETURN
  691.    ENDIF
  692.    
  693.     * SUM or replace for non numeric data types
  694.       IF TYPE(m.f2) $ "NFYBI"
  695.           IF ISNULL(&f2)
  696.               nAccumTot = IIF(ISNULL(m.f3),.NULL.,m.f3)
  697.           ELSE
  698.               nAccumTot = &f2 + IIF(ISNULL(m.f3),0,m.f3)
  699.           ENDIF
  700.            REPLACE (m.f2) WITH m.nAccumTot
  701.     ELSE
  702.            REPLACE (m.f2) WITH m.f3
  703.     ENDIF
  704.    
  705.    SELECT (m.dbfstem)
  706.    
  707.    * Map thermometer to remaining portion of display
  708.    DO CASE
  709.       CASE RECCOUNT() > 1000
  710.          IF RECNO() % 100 = 0
  711.             THIS.updtherm(INT(RECNO()/RECCOUNT()*60)+35,C_THERM5_LOC)
  712.          ENDIF
  713.       OTHERWISE
  714.          IF RECNO() % 10  = 0
  715.             THIS.updtherm(INT(RECNO()/RECCOUNT()*55)+35,C_THERM5_LOC)
  716.          ENDIF
  717.    ENDCASE
  718. ENDSCAN
  719.  
  720.  
  721. * Cross-foot the columns and put the results into the total field
  722. IF THIS.xfoot
  723.    THIS.updtherm(90,C_THERM6_LOC)
  724.    SELECT (THIS.outstem)
  725.    m.totfldname = FIELD(FCOUNT())
  726.    IF THIS.totaltype = PERCENT_FIELDS
  727.         * Need to get total here    
  728.         PRIVATE aSums,nFirstField
  729.         m.nFirstField = IIF(ATC(m.RowFldType,"NFIYB")=0,1,2)
  730.         SUM ALL TO ARRAY aSums
  731.         m.sumallflds = 0
  732.         FOR i = m.nFirstField TO (ALEN(aSums)-1)        &&skip last field which has totals
  733.             m.sumallflds = m.sumallflds + aSums[m.i] 
  734.         ENDFOR
  735.    ENDIF
  736.    SCAN
  737.       * Sum the relevant fields
  738.       m.gtotal = .NULL.
  739.       FOR i = 2 TO FCOUNT() - 1
  740.         IF ISNULL(EVAL(FIELD(m.i)))
  741.             LOOP
  742.         ENDIF
  743.         IF ISNULL(m.gtotal) AND !ISNULL(EVAL(FIELD(m.i))) 
  744.             gtotal = 0
  745.           ENDIF
  746.            DO CASE
  747.         CASE THIS.totaltype = COUNT_FIELDS
  748.             * Count values
  749.             IF THIS.shownulls
  750.                 gtotal = m.gtotal + IIF(ISNULL(EVAL(FIELD(m.i))),0,1)
  751.             ELSE
  752.                 cTmpField = field(m.i)
  753.                 gtotal = m.gtotal + IIF(ISBLANK(&cTmpField),0,1)    
  754.             ENDIF
  755.           OTHERWISE
  756.             * SUM values
  757.             gtotal = m.gtotal + EVAL(FIELD(m.i))
  758.           ENDCASE
  759.       ENDFOR
  760.       IF THIS.totaltype = PERCENT_FIELDS
  761.               gtotal = IIF(m.sumallflds=0 OR ISNULL(m.gtotal) OR m.gtotal=0,0,ROUND(m.gtotal/m.sumallflds*100,THIS.nPercentFldDec))
  762.       ENDIF
  763.       REPLACE (m.totfldname) WITH m.gtotal
  764.    ENDSCAN
  765. ENDIF
  766.  
  767. THIS.updtherm(100)
  768.  
  769. IF USED("XTABTEMP")
  770.    USE IN xtabtemp
  771. ENDIF
  772.  
  773. IF FILE("xtabtemp.dbf")
  774.    DELETE FILE xtabtemp.dbf
  775. ENDIF
  776.  
  777. * Close the input database
  778. IF THIS.closeinput
  779.    SELECT (m.dbfstem)
  780.    USE
  781. ENDIF
  782.  
  783. * Leave the output database/cursor selected
  784. SELECT (THIS.outstem)
  785. GOTO TOP
  786. THIS.deactthermo()
  787.  
  788. * Do closing housekeeping
  789. RETURN
  790. ENDPROC
  791.  
  792.  
  793. *!*********************************************************************
  794. *!
  795. *!       Function: MAPNAME()
  796. *!
  797. *!*********************************************************************
  798. FUNCTION mapname
  799. * Translate a field value of any type into a string containing a valid
  800. * field name.
  801.  
  802. PARAMETER in_name, in_dec
  803. LOCAL retval
  804.  
  805. IF PARAMETERS() = 1
  806.    m.in_dec = 0
  807. ENDIF
  808. DO CASE
  809. CASE ISNULL(m.in_name)
  810.     m.retval = THIS.null_field 
  811. CASE TYPE("m.in_name") $ 'CM'
  812.    DO CASE
  813.    CASE EMPTY(m.in_name)
  814.       m.retval = THIS.char_blank
  815.    OTHERWISE
  816.          * We need to replace bad characters here with "_"
  817.       m.retval = CHRTRANC(m.in_name,THIS.badchars,REPLICATE("_",LEN(THIS.badchars)-1))
  818.       
  819.       IF !ISALPHA(LEFT(m.retval,1))
  820.          m.retval = 'C_'+m.retval
  821.       ENDIF
  822.       * Now have to truncate to 10 bytes (not 10 chars)
  823.       m.retval=SUBSTR(m.retval,1,10)    && first 10 bytes
  824.       IF LEN(RIGHTC(m.retval,1)) = 1 AND IsLeadByte(RIGHTC(m.retval,1))    && last byte is Double byte
  825.         m.retval = SUBSTR(m.retval,1,9)
  826.       ENDIF
  827.  
  828.    ENDCASE
  829. CASE TYPE("m.in_name") $ 'NFIYB'
  830.    m.retval = 'N_'+ALLTRIM(CHRTRANC(STR(m.in_name,8,MIN(in_dec,18)),'.',''))
  831.    m.retval = CHRTRANC(m.retval,'-,','__')
  832. CASE TYPE("m.in_name") $ 'DT'
  833.    DO CASE
  834.    CASE EMPTY(m.in_name)
  835.       m.retval = THIS.date_blank
  836.    OTHERWISE
  837.       m.retval = 'D_' + CHRTRANC(DTOS(m.in_name),THIS.badchars,REPLICATE("_",LEN(THIS.badchars)-1))
  838.    ENDCASE
  839. CASE TYPE("m.in_name") = 'L'
  840.    IF m.in_name = .T.
  841.       m.retval = 'T'
  842.    ELSE
  843.       m.retval = 'F'
  844.    ENDIF
  845. OTHERWISE
  846.    * Should never happen
  847.    THIS.alert(C_UNKNOWNFLD_LOC)
  848.    RETURN ""
  849. ENDCASE
  850.  
  851.  
  852. RETURN PADR(UPPER(ALLTRIM(m.retval)),10)
  853.  
  854. ENDFUNC
  855.  
  856. *!*********************************************************************
  857. *!
  858. *!      Procedure: CheckField
  859. *!
  860. *!*********************************************************************
  861. PROCEDURE CheckField
  862. PARAMETER aCheckArray,cCheckValue
  863. * Checks to see if field name is unique, else assigns a new one
  864. LOCAL oldExact,nTmpCnt,cTmpCntStr,cOldValue 
  865. oldexact = SET("EXACT")
  866. SET EXACT ON
  867. IF LEN(ALLTRIM(m.cCheckValue)) > 10
  868.     cCheckValue = LEFT(ALLTRIM(m.cCheckValue),10)
  869. ENDIF
  870. cOldValue = m.cCheckValue
  871. nTmpCnt = 1
  872. DO WHILE ASCAN(aCheckArray,m.cCheckValue)#0
  873.     cTmpCntStr = "_"+ALLTRIM(STR(m.nTmpCnt))
  874.     cCheckValue = LEFT(ALLTRIM(m.cOldValue),10-LEN(m.cTmpCntStr)) + m.cTmpCntStr
  875.     nTmpCnt = m.nTmpCnt + 1
  876. ENDDO
  877. SET EXACT &oldexact
  878. RETURN m.cCheckValue
  879. ENDPROC
  880.  
  881. *!*********************************************************************
  882. *!
  883. *!      Procedure: ERROR
  884. *!
  885. *!*********************************************************************
  886. PROCEDURE ERROR
  887. PARAMETERS nError,cMethod,nLine
  888. THIS.alert(ERR_LINE_LOC+ALLTRIM(STR(m.nLine))+CHR(13) ;
  889.    +ERR_PROGRAM_LOC+m.cMethod+CHR(13) ;
  890.    +ERR_ERROR_LOC+ALLTRIM(STR(nError))+CHR(13) ;
  891.    +ERR_MESSAGE_LOC+MESSAGE()+CHR(13);
  892.    +ERR_CODE_LOC+MESSAGE(1))
  893.    
  894.    THIS.failxtab = .T.
  895.    RETURN TO MakeXtab
  896. ENDPROC
  897.  
  898. *!*********************************************************************
  899. *!
  900. *!      Procedure: ALERT
  901. *!
  902. *!*********************************************************************
  903. PROCEDURE alert
  904. LPARAMETERS strg
  905. =MESSAGEBOX(m.strg)
  906. RETURN
  907. ENDPROC
  908.  
  909. *!*********************************************************************
  910. *!
  911. *!      Procedure: ESC_PROC
  912. *!
  913. *!*********************************************************************
  914. PROCEDURE esc_proc
  915.     CLEAR TYPEAHEAD
  916.     IF MESSAGEBOX(C_XTABTERM_LOC,36) = 6
  917.         RETURN
  918.     ELSE
  919.         THIS.failxtab = .T.
  920.         RETURN TO MakeXtab
  921.     ENDIF
  922. ENDPROC
  923.  
  924. *!*****************************************************************************
  925. *!
  926. *!      Procedure: PARTIALFNAME
  927. *!
  928. *!*****************************************************************************
  929. FUNCTION partialfname
  930. PARAMETER m.filname, m.fillen
  931. * Return a filname no longer than m.fillen characters.  Take some chars
  932. * out of the middle if necessary.  No matter what m.fillen is, this function
  933. * always returns at least the file stem and extension.
  934. PRIVATE m.bname, m.elipse
  935. m.elipse = "..." + c_pathsep
  936. m.bname = THIS.justfname(m.filname)
  937. DO CASE
  938. CASE LEN(m.filname) <= m.fillen 
  939.    RETURN filname
  940. CASE LEN(m.bname) + LEN(m.elipse) >= m.fillen
  941.    RETURN m.bname
  942. OTHERWISE
  943.    m.remain = MAX(m.fillen - LEN(m.bname) - LEN(m.elipse), 0)
  944.    RETURN LEFT(THIS.justpath(m.filname),remain)+m.elipse+m.bname
  945. ENDCASE
  946. ENDFUNC
  947.  
  948. *!*****************************************************************************
  949. *!
  950. *!      Procedure: removequotes
  951. *!
  952. *!*****************************************************************************
  953. FUNCTION removequotes
  954. PARAMETER m.fname
  955. PRIVATE m.leftchar, m.rightchar
  956. m.fname = ALLTRIM(m.fname)
  957. m.leftchar = LEFT(m.fname,1)
  958. m.rightchar = RIGHT(m.fname, 1)
  959.  
  960. IF m.leftchar = '"' AND m.rightchar = '"'    ;
  961.     OR m.leftchar = "'" AND m.rightchar = "'"  ;
  962.     OR m.leftchar = '[' AND m.rightchar = ']'
  963.         RETURN SUBSTR(m.fname, 2, LEN(m.fname) - 2)
  964. ELSE
  965.    RETURN m.fname        
  966. ENDIF
  967. ENDFUNC
  968.  
  969. *!*********************************************************************
  970. *!
  971. *!       Function: JUSTSTEM()
  972. *!
  973. *!*********************************************************************
  974. FUNCTION juststem
  975. * Return just the stem name from "filname"
  976. PARAMETERS filname
  977. PRIVATE ALL
  978. IF RAT('\',m.filname) > 0
  979.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  980. ENDIF
  981. IF RAT(':',m.filname) > 0
  982.    m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255)
  983. ENDIF
  984. IF RAT('.',m.filname) > 0
  985.    m.filname = SUBSTR(m.filname,1,RAT('.',m.filname)-1)
  986. ENDIF
  987. RETURN ALLTRIM(UPPER(m.filname))
  988. ENDFUNC
  989.  
  990. *!*********************************************************************
  991. *!
  992. *!      Procedure: FORCEEXT
  993. *!
  994. *!*********************************************************************
  995. FUNCTION forceext
  996. * Force the extension of "filname" to be whatever ext is.
  997. PARAMETERS filname,ext
  998. PRIVATE ALL
  999. IF SUBSTR(m.ext,1,1) = "."
  1000.    m.ext = SUBSTR(m.ext,2,3)
  1001. ENDIF
  1002.  
  1003. m.pname = THIS.justpath(m.filname)
  1004. m.filname = THIS.justfname(UPPER(ALLTRIM(m.filname)))
  1005. IF RAT('.',m.filname) > 0
  1006.    m.filname = SUBSTR(m.filname,1,RAT('.',m.filname)-1) + '.' + m.ext
  1007. ELSE
  1008.    m.filname = m.filname + '.' + m.ext
  1009. ENDIF
  1010. RETURN THIS.addbs(m.pname) + m.filname
  1011. ENDFUNC
  1012.  
  1013. *!*********************************************************************
  1014. *!
  1015. *!       Function: DEFAULTEXT()
  1016. *!
  1017. *!*********************************************************************
  1018. FUNCTION defaultext
  1019. * Add a default extension to "filname" if it doesn't have one already
  1020. PARAMETERS filname,ext
  1021. PRIVATE ALL
  1022. IF SUBSTR(ext,1,1) = "."
  1023.    m.ext = SUBSTR(m.ext,2,3)
  1024. ENDIF
  1025.  
  1026. m.pname = THIS.justpath(m.filname)
  1027. m.filname = THIS.justfname(UPPER(ALLTRIM(m.filname)))
  1028. IF !EMPTY(m.filname) AND AT('.',m.filname) = 0
  1029.    m.filname = m.filname + '.' + m.ext
  1030.    RETURN THIS.addbs(m.pname) + m.filname
  1031. ELSE
  1032.    RETURN filname
  1033. ENDIF
  1034. ENDFUNC
  1035.  
  1036. *!*********************************************************************
  1037. *!
  1038. *!       Function: JUSTFNAME()
  1039. *!
  1040. *!*********************************************************************
  1041. FUNCTION justfname
  1042. * Return just the filename (i.e., no path) from "filname"
  1043. PARAMETERS filname
  1044. PRIVATE ALL
  1045. IF RAT('\',m.filname) > 0
  1046.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  1047. ENDIF
  1048. IF RAT(':',m.filname) > 0
  1049.    m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255)
  1050. ENDIF
  1051. RETURN ALLTRIM(UPPER(m.filname))
  1052. ENDPROC
  1053.  
  1054. *!*********************************************************************
  1055. *!
  1056. *!      Procedure: JUSTPATH
  1057. *!
  1058. *!*********************************************************************
  1059. FUNCTION justpath
  1060. * Return just the path name from "filname"
  1061. PARAMETERS m.filname
  1062. PRIVATE ALL
  1063. m.filname = ALLTRIM(UPPER(m.filname))
  1064. m.pathsep = IIF(_MAC,":", "\")
  1065. IF _MAC
  1066.    m.found_it = .F.
  1067.    m.maxchar = max(RAT("\", m.filname), RAT(":", m.filname))
  1068.    IF m.maxchar > 0
  1069.       m.filname = SUBSTR(m.filname,1,m.maxchar)
  1070.       IF RIGHT(m.filname,1) $ ":\" AND LEN(m.filname) > 1 ;
  1071.             AND !(SUBSTR(m.filname,LEN(m.filname)-1,1)  $ ":\")
  1072.          m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  1073.       ENDIF
  1074.       RETURN m.filname
  1075.    ENDIF
  1076. ELSE
  1077.    IF m.pathsep $ filname
  1078.       m.filname = SUBSTR(m.filname,1,RAT(m.pathsep,m.filname))
  1079.       IF RIGHT(m.filname,1) = m.pathsep AND LEN(m.filname) > 1 ;
  1080.             AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> m.pathsep
  1081.          m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  1082.       ENDIF
  1083.       RETURN m.filname
  1084.    ENDIF      
  1085. ENDIF
  1086. RETURN ''
  1087. ENDPROC
  1088.  
  1089. *!*********************************************************************
  1090. *!
  1091. *!      Procedure: ADDBS
  1092. *!
  1093. *!*********************************************************************
  1094. FUNCTION addbs
  1095. * Add a backslash to a path name, if there isn't already one there
  1096. PARAMETER pathname
  1097. PRIVATE ALL
  1098. m.pathname = ALLTRIM(UPPER(m.pathname))
  1099. IF !(RIGHT(m.pathname,1) $ '\:') AND !EMPTY(m.pathname)
  1100.    m.pathname = m.pathname + IIF(_MAC,":",'\')
  1101. ENDIF
  1102. RETURN m.pathname
  1103. ENDPROC
  1104.  
  1105.  
  1106. *!*********************************************************************
  1107. *!
  1108. *!      Procedure: HasModalForm
  1109. *!
  1110. *!*********************************************************************
  1111. PROCEDURE HasModalForm
  1112. * Tests to see if a modal form is active and uses status bar
  1113. * Note: This is commented out, however, if you prefer to use the status bar
  1114. * remove the following line
  1115. RETURN .F.
  1116. LOCAL i
  1117. FOR i = 1 TO _SCREEN.FormCount
  1118.     IF _Screen.Forms[m.i].Windowtype = 1 OR ;
  1119.      (TYPE("_Screen.Forms[m.i].Parent.Windowtype")="N" AND ;
  1120.     _Screen.Forms[m.i].Parent.Windowtype = 1)
  1121.         RETURN .T.
  1122.         EXIT
  1123.     ENDIF
  1124. ENDFOR
  1125. RETURN .F.
  1126. ENDPROC
  1127.  
  1128. *!*********************************************************************
  1129. *!
  1130. *!      Procedure: ActTherm
  1131. *!
  1132. *!*********************************************************************
  1133. PROCEDURE ActTherm
  1134. PARAMETER prompt
  1135. IF !THIS.therm_on
  1136.     RETURN
  1137. ENDIF
  1138. * Test to see if we have a modal form up which prevents Therm window from being visible.
  1139. IF THIS.HasModalForm()
  1140.     THIS.lHasModalFormOnTop = .T.
  1141.     RETURN
  1142. ENDIF
  1143. THIS.oThermRef = CREATEOBJECT("thermometer",m.prompt)
  1144. THIS.oThermRef.Show()
  1145. ENDPROC
  1146.  
  1147. *!*********************************************************************
  1148. *!
  1149. *!      Procedure: updtherm 
  1150. *!
  1151. *!*********************************************************************
  1152. PROCEDURE updtherm
  1153. LPARAMETER Percent,cTask
  1154. IF !THIS.therm_on
  1155.     RETURN
  1156. ENDIF
  1157. IF THIS.lHasModalFormOnTop
  1158.     SET MESSAGE TO C_THERM1_LOC+ALLTRIM(STR(m.percent))+"%"
  1159.     RETURN
  1160. ENDIF
  1161. IF m.Percent = 100
  1162.     THIS.oThermRef.Complete()
  1163. ELSE
  1164.     THIS.oThermRef.Update(m.Percent,cTask)
  1165. ENDIF
  1166. ENDPROC
  1167.  
  1168. *!*********************************************************************
  1169. *!
  1170. *!      Procedure: deactthermo
  1171. *!
  1172. *!*********************************************************************
  1173. PROCEDURE deactthermo
  1174.     IF !THIS.therm_on
  1175.         RETURN
  1176.     ENDIF
  1177.     IF THIS.lHasModalFormOnTop
  1178.         RETURN
  1179.     ENDIF    
  1180.     IF TYPE("THIS.oThermRef") = "O"
  1181.        THIS.oThermRef.Release()
  1182.     ENDIF
  1183. ENDPROC
  1184.  
  1185. ENDDEFINE
  1186.  
  1187.  
  1188. ***********************************************************************
  1189. ***********************************************************************
  1190. DEFINE CLASS thermometer AS form
  1191.  
  1192.     Top = 196
  1193.     Left = 142
  1194.     Height = 88
  1195.     Width = 356
  1196.     AutoCenter = .T.
  1197.     BackColor = RGB(192,192,192)
  1198.     BorderStyle = 0
  1199.     Caption = ""
  1200.     Closable = .F.
  1201.     ControlBox = .F.
  1202.     MaxButton = .F.
  1203.     MinButton = .F.
  1204.     Movable = .F.
  1205.     AlwaysOnTop = .F.
  1206.     ipercentage = 0
  1207.     ccurrenttask = ''
  1208.     shpthermbarmaxwidth = 322
  1209.     cthermref = ""
  1210.     Name = "thermometer"
  1211.  
  1212.     ADD OBJECT shape10 AS shape WITH ;
  1213.         BorderColor = RGB(128,128,128), ;
  1214.         Height = 81, ;
  1215.         Left = 3, ;
  1216.         Top = 3, ;
  1217.         Width = 1, ;
  1218.         Name = "Shape10"
  1219.  
  1220.  
  1221.     ADD OBJECT shape9 AS shape WITH ;
  1222.         BorderColor = RGB(128,128,128), ;
  1223.         Height = 1, ;
  1224.         Left = 3, ;
  1225.         Top = 3, ;
  1226.         Width = 349, ;
  1227.         Name = "Shape9"
  1228.  
  1229.  
  1230.     ADD OBJECT shape8 AS shape WITH ;
  1231.         BorderColor = RGB(255,255,255), ;
  1232.         Height = 82, ;
  1233.         Left = 352, ;
  1234.         Top = 3, ;
  1235.         Width = 1, ;
  1236.         Name = "Shape8"
  1237.  
  1238.  
  1239.     ADD OBJECT shape7 AS shape WITH ;
  1240.         BorderColor = RGB(255,255,255), ;
  1241.         Height = 1, ;
  1242.         Left = 3, ;
  1243.         Top = 84, ;
  1244.         Width = 350, ;
  1245.         Name = "Shape7"
  1246.  
  1247.  
  1248.     ADD OBJECT shape6 AS shape WITH ;
  1249.         BorderColor = RGB(128,128,128), ;
  1250.         Height = 86, ;
  1251.         Left = 354, ;
  1252.         Top = 1, ;
  1253.         Width = 1, ;
  1254.         Name = "Shape6"
  1255.  
  1256.  
  1257.     ADD OBJECT shape4 AS shape WITH ;
  1258.         BorderColor = RGB(128,128,128), ;
  1259.         Height = 1, ;
  1260.         Left = 1, ;
  1261.         Top = 86, ;
  1262.         Width = 354, ;
  1263.         Name = "Shape4"
  1264.  
  1265.  
  1266.     ADD OBJECT shape3 AS shape WITH ;
  1267.         BorderColor = RGB(255,255,255), ;
  1268.         Height = 85, ;
  1269.         Left = 1, ;
  1270.         Top = 1, ;
  1271.         Width = 1, ;
  1272.         Name = "Shape3"
  1273.  
  1274.  
  1275.     ADD OBJECT shape2 AS shape WITH ;
  1276.         BorderColor = RGB(255,255,255), ;
  1277.         Height = 1, ;
  1278.         Left = 1, ;
  1279.         Top = 1, ;
  1280.         Width = 353, ;
  1281.         Name = "Shape2"
  1282.  
  1283.  
  1284.     ADD OBJECT shape1 AS shape WITH ;
  1285.         BackStyle = 0, ;
  1286.         Height = 88, ;
  1287.         Left = 0, ;
  1288.         Top = 0, ;
  1289.         Width = 356, ;
  1290.         Name = "Shape1"
  1291.  
  1292.  
  1293.     ADD OBJECT shape5 AS shape WITH ;
  1294.         BorderStyle = 0, ;
  1295.         FillColor = RGB(192,192,192), ;
  1296.         FillStyle = 0, ;
  1297.         Height = 15, ;
  1298.         Left = 17, ;
  1299.         Top = 47, ;
  1300.         Width = 322, ;
  1301.         Name = "Shape5"
  1302.  
  1303.  
  1304.     ADD OBJECT lbltitle AS label WITH ;
  1305.         FontName = WIN32FONT, ;
  1306.         FontSize = 8, ;
  1307.         BackStyle = 0, ;
  1308.         BackColor = RGB(192,192,192), ;
  1309.         Caption = "", ;
  1310.         Height = 16, ;
  1311.         Left = 18, ;
  1312.         Top = 14, ;
  1313.         Width = 319, ;
  1314.         WordWrap = .F., ;
  1315.         Name = "lblTitle"
  1316.  
  1317.  
  1318.     ADD OBJECT lbltask AS label WITH ;
  1319.         FontName = WIN32FONT, ;
  1320.         FontSize = 8, ;
  1321.         BackStyle = 0, ;
  1322.         BackColor = RGB(192,192,192), ;
  1323.         Caption = "", ;
  1324.         Height = 16, ;
  1325.         Left = 18, ;
  1326.         Top = 27, ;
  1327.         Width = 319, ;
  1328.         WordWrap = .F., ;
  1329.         Name = "lblTask"
  1330.  
  1331.  
  1332.     ADD OBJECT shpthermbar AS shape WITH ;
  1333.         BorderStyle = 0, ;
  1334.         FillColor = RGB(128,128,128), ;
  1335.         FillStyle = 0, ;
  1336.         Height = 16, ;
  1337.         Left = 17, ;
  1338.         Top = 46, ;
  1339.         Width = 0, ;
  1340.         Name = "shpThermBar"
  1341.  
  1342.  
  1343.     ADD OBJECT lblpercentage AS label WITH ;
  1344.         FontName = WIN32FONT, ;
  1345.         FontSize = 8, ;
  1346.         BackStyle = 0, ;
  1347.         Caption = "0%", ;
  1348.         Height = 13, ;
  1349.         Left = 170, ;
  1350.         Top = 47, ;
  1351.         Width = 16, ;
  1352.         Name = "lblPercentage"
  1353.  
  1354.  
  1355.     ADD OBJECT lblpercentage2 AS label WITH ;
  1356.         FontName = WIN32FONT, ;
  1357.         FontSize = 8, ;
  1358.         BackColor = RGB(0,0,255), ;
  1359.         BackStyle = 0, ;
  1360.         Caption = "Label1", ;
  1361.         ForeColor = RGB(255,255,255), ;
  1362.         Height = 13, ;
  1363.         Left = 170, ;
  1364.         Top = 47, ;
  1365.         Width = 0, ;
  1366.         Name = "lblPercentage2"
  1367.  
  1368.  
  1369.     ADD OBJECT shape11 AS shape WITH ;
  1370.         BorderColor = RGB(128,128,128), ;
  1371.         Height = 1, ;
  1372.         Left = 16, ;
  1373.         Top = 45, ;
  1374.         Width = 322, ;
  1375.         Name = "Shape11"
  1376.  
  1377.  
  1378.     ADD OBJECT shape12 AS shape WITH ;
  1379.         BorderColor = RGB(255,255,255), ;
  1380.         Height = 1, ;
  1381.         Left = 16, ;
  1382.         Top = 61, ;
  1383.         Width = 323, ;
  1384.         Name = "Shape12"
  1385.  
  1386.  
  1387.     ADD OBJECT shape13 AS shape WITH ;
  1388.         BorderColor = RGB(128,128,128), ;
  1389.         Height = 16, ;
  1390.         Left = 16, ;
  1391.         Top = 45, ;
  1392.         Width = 1, ;
  1393.         Name = "Shape13"
  1394.  
  1395.  
  1396.     ADD OBJECT shape14 AS shape WITH ;
  1397.         BorderColor = RGB(255,255,255), ;
  1398.         Height = 17, ;
  1399.         Left = 338, ;
  1400.         Top = 45, ;
  1401.         Width = 1, ;
  1402.         Name = "Shape14"
  1403.  
  1404.  
  1405.     ADD OBJECT lblescapemessage AS label WITH ;
  1406.         FontBold = .F., ;
  1407.         FontName = WIN32FONT, ;
  1408.         FontSize = 8, ;
  1409.         Alignment = 2, ;
  1410.         BackStyle = 0, ;
  1411.         BackColor = RGB(192,192,192), ;
  1412.         Caption = "", ;
  1413.         Height = 14, ;
  1414.         Left = 17, ;
  1415.         Top = 68, ;
  1416.         Width = 322, ;
  1417.         WordWrap = .F., ;
  1418.         Name = "lblEscapeMessage"
  1419.  
  1420.  
  1421. *!*********************************************************************
  1422. *!
  1423. *!      Procedure: complete
  1424. *!
  1425. *!*********************************************************************
  1426. PROCEDURE complete
  1427.         * This is the default complete message
  1428.         parameters m.cTask
  1429.         private iSeconds
  1430.         if parameters() = 0
  1431.             m.cTask = THERMCOMPLETE_LOC
  1432.         endif
  1433.         this.Update(100,m.cTask)
  1434. ENDPROC
  1435.  
  1436.  
  1437. *!*********************************************************************
  1438. *!
  1439. *!      Procedure: update
  1440. *!
  1441. *!*********************************************************************
  1442. PROCEDURE update
  1443.         * m.iProgress is the percentage complete
  1444.         * m.cTask is displayed on the second line of the window
  1445.  
  1446.         parameters iProgress,cTask
  1447.  
  1448.         if parameters() >= 2 .and. type('m.cTask') = 'C'
  1449.             * If we're specifically passed a null string, clear the current task,
  1450.             * otherwise leave it alone
  1451.             this.cCurrentTask = m.cTask
  1452.         endif
  1453.         
  1454.         if ! this.lblTask.Caption == this.cCurrentTask
  1455.             this.lblTask.Caption = this.cCurrentTask
  1456.         endif
  1457.  
  1458.         m.iPercentage = m.iProgress
  1459.         m.iPercentage = min(100,max(0,m.iPercentage))
  1460.         
  1461.         if m.iPercentage = this.iPercentage
  1462.             RETURN
  1463.         endif
  1464.         
  1465.         if len(alltrim(str(m.iPercentage,3)))<>len(alltrim(str(this.iPercentage,3)))
  1466.             iAvgCharWidth=fontmetric(6,this.lblPercentage.FontName, ;
  1467.                 this.lblPercentage.FontSize, ;
  1468.                 iif(this.lblPercentage.FontBold,'B','')+ ;
  1469.                 iif(this.lblPercentage.FontItalic,'I',''))
  1470.             this.lblPercentage.Width=txtwidth(alltrim(str(m.iPercentage,3)) + '%', ;
  1471.                 this.lblPercentage.FontName,this.lblPercentage.FontSize, ;
  1472.                 iif(this.lblPercentage.FontBold,'B','')+ ;
  1473.                 iif(this.lblPercentage.FontItalic,'I','')) * iAvgCharWidth
  1474.             this.lblPercentage.Left=int((this.shpThermBarMaxWidth- ;
  1475.                 this.lblPercentage.Width) / 2)+this.shpThermBar.Left-1
  1476.             this.lblPercentage2.Left=this.lblPercentage.Left
  1477.         endif
  1478.         this.shpThermBar.Width = int((this.shpThermBarMaxWidth)*m.iPercentage/100)
  1479.         this.lblPercentage.Caption = alltrim(str(m.iPercentage,3)) + '%'
  1480.         this.lblPercentage2.Caption = this.lblPercentage.Caption
  1481.         if this.shpThermBar.Left + this.shpThermBar.Width -1 >= ;
  1482.             this.lblPercentage2.Left
  1483.             if this.shpThermBar.Left + this.shpThermBar.Width - 1 >= ;
  1484.                 this.lblPercentage2.Left + this.lblPercentage.Width - 1
  1485.                 this.lblPercentage2.Width = this.lblPercentage.Width
  1486.             else
  1487.                 this.lblPercentage2.Width = ;
  1488.                     this.shpThermBar.Left + this.shpThermBar.Width - ;
  1489.                     this.lblPercentage2.Left - 1
  1490.             endif
  1491.         else
  1492.             this.lblPercentage2.Width = 0
  1493.         endif
  1494.         this.iPercentage = m.iPercentage
  1495. ENDPROC
  1496.  
  1497. *!*********************************************************************
  1498. *!
  1499. *!      Procedure: Init
  1500. *!
  1501. *!*********************************************************************
  1502. PROCEDURE Init
  1503.         * m.cTitle is displayed on the first line of the window
  1504.         * m.iInterval is the frequency used for updating the thermometer
  1505.         parameters cTitle, iInterval
  1506.         this.lblTitle.Caption = iif(empty(m.cTitle),'',m.cTitle)
  1507.         this.shpThermBar.FillColor = rgb(128,128,128)
  1508.         local cColor
  1509.  
  1510.         * Check to see if the fontmetrics for MS Sans Serif matches
  1511.         * those on the system developed. If not, switch to Arial. 
  1512.         * The RETURN value indicates whether the font was changed.
  1513.         if fontmetric(1, WIN32FONT, 8, '') <> 13 .or. ;
  1514.             fontmetric(4, WIN32FONT, 8, '') <> 2 .or. ;
  1515.             fontmetric(6, WIN32FONT, 8, '') <> 5 .or. ;
  1516.             fontmetric(7, WIN32FONT, 8, '') <> 11
  1517.             this.SetAll('FontName', WIN95FONT)
  1518.         endif
  1519.  
  1520.         m.cColor = rgbscheme(1, 2)
  1521.         m.cColor = 'rgb(' + substr(m.cColor, at(',', m.cColor, 3) + 1)
  1522.         this.BackColor = &cColor
  1523.         this.Shape5.FillColor = &cColor
  1524. ENDPROC
  1525.  
  1526. ENDDEFINE
  1527.